﻿Imports System.IO
Imports System
Imports System.IO.Packaging
Imports Microsoft.Office.Interop.Word

'TODO: Führen Sie diese Schritte aus, um das Element auf dem Menüband (XML) zu aktivieren:

'1: Kopieren Sie folgenden Codeblock in die ThisAddin-, ThisWorkbook- oder ThisDocument-Klasse.

'Protected Overrides Function CreateRibbonExtensibilityObject() As Microsoft.Office.Core.IRibbonExtensibility
'    Return New EBookGenRibbon()
'End Function

'2. Erstellen Sie Rückrufmethoden im Abschnitt "Menübandrückrufe" dieser Klasse, um Benutzeraktionen
'   zu behandeln, zum Beispiel das Klicken auf eine Schaltfläche. Hinweis: Wenn Sie dieses Menüband aus dem
'   Menüband-Designer exportiert haben, verschieben Sie den Code aus den Ereignishandlern in die Rückrufmethoden, und
'   ändern Sie den Code für die Verwendung mit dem Programmiermodell für die Menübanderweiterung (RibbonX).

'3. Weisen Sie den Steuerelementtags in der Menüband-XML-Datei Attribute zu, um die entsprechenden Rückrufmethoden im Code anzugeben.

'Weitere Informationen erhalten Sie in der Menüband-XML-Dokumentation in der Hilfe zu Visual Studio-Tools für Office.

<Runtime.InteropServices.ComVisible(True)> _
Public Class EBookGenRibbon
    Implements Office.IRibbonExtensibility

    Private ribbon As Office.IRibbonUI
    Public Property fileToDelete() As String

    Public Sub New()
    End Sub

    Public Function GetCustomUI(ByVal ribbonID As String) As String Implements Office.IRibbonExtensibility.GetCustomUI
        Return GetResourceText("EBookGen.EBookGenRibbon.xml")
    End Function

#Region "Menübandrückrufe"
    'Erstellen Sie hier Rückrufmethoden. Weitere Informationen über das Hinzufügen von Rückrufmethoden erhalten Sie, indem Sie das Menüband-XML-Element im Projektmappen-Explorer markieren und dann F1 drücken.
    Public Sub Ribbon_Load(ByVal ribbonUI As Office.IRibbonUI)
        Me.ribbon = ribbonUI

        ' von Daniel
        Dim document As Microsoft.Office.Interop.Word.Document = Globals.ThisDocument.Application.ActiveDocument

        For Each vorlage As Word.Style In document.Styles
            Dim thisStyle As Word.Style = vorlage   ' Zugriff auf Formatvorlagen
            Dim datFont As Word.Font = vorlage.Font ' Zugriff auf all things font
            Dim datName As String = vorlage.NameLocal ' Zugriff auf den Namen, unter dem es angezeigt wird (denk ich)
        Next
        'Ende

    End Sub

    Public Sub HtmlSaveAction(ByVal control As Office.IRibbonControl)
        'System.Windows.Forms.MessageBox.Show("Html Button clicked !")

        ' Default path
        Dim path As String = "C:\Html\"

        Dim Writer1 As New Writer

        'Show save dialog and get target path
        Dim htmlDialogSaveAs As Microsoft.Office.Core.FileDialog
        Dim ret As Long
        htmlDialogSaveAs = Globals.ThisDocument.Application.FileDialog(Microsoft.Office.Core.MsoFileDialogType.msoFileDialogSaveAs)
        htmlDialogSaveAs.AllowMultiSelect = False
        htmlDialogSaveAs.Title = "HTML speichern"

        ret = htmlDialogSaveAs.Show
        If ret <> 0 Then
            Dim filename As String = getFilenameFromPath(htmlDialogSaveAs.SelectedItems(0))
            Dim realPath As String = correctPathHtml(htmlDialogSaveAs.SelectedItems(0))

            ' read word object structure
            Dim document As Microsoft.Office.Interop.Word.Document = Globals.ThisDocument.Application.ActiveDocument
            Dim newDocument As MyDocument = readWordDocument(document, realPath)

            Writer1.writeHtml(filename, newDocument, realPath)
        Else
            'for debugging
            MsgBox("User Canceled Saving")
        End If



    End Sub

    Public Sub EpubSaveAction(ByVal control As Office.IRibbonControl)
        'System.Windows.Forms.MessageBox.Show("Epub Button clicked !")

        ' default path
        Dim path As String = "C:\epub"

        Dim Writer1 As New Writer

        'Show save dialog and get target path
        Dim htmlDialogSaveAs As Microsoft.Office.Core.FileDialog
        Dim ret As Long
        htmlDialogSaveAs = Globals.ThisDocument.Application.FileDialog(Microsoft.Office.Core.MsoFileDialogType.msoFileDialogSaveAs)
        htmlDialogSaveAs.AllowMultiSelect = False
        htmlDialogSaveAs.Title = "EPub speichern"

        ret = htmlDialogSaveAs.Show
        If ret <> 0 Then
            Dim filename As String = getFilenameFromPath(htmlDialogSaveAs.SelectedItems(0))
            Dim realPath As String = correctPathEpub(htmlDialogSaveAs.SelectedItems(0))

            ' read word object structure
            Dim document As Microsoft.Office.Interop.Word.Document = Globals.ThisDocument.Application.ActiveDocument
            Dim newDocument As MyDocument = readWordDocument(document, realPath)

            Writer1.writeEPub(filename, newDocument, realPath)
        Else
            'for debugging
            MsgBox("User Canceled Saving")
        End If

    End Sub

#End Region

#Region "Hilfsprogramme"

    Private Function getFilenameFromPath(ByVal path As String) As String
        Dim indexLastDot As Integer
        Dim indexLastSlash As Integer
        indexLastDot = path.LastIndexOf(".")
        indexLastSlash = path.LastIndexOf(Globals.ThisDocument.Application.PathSeparator)
        Return path.Substring(indexLastSlash + 1, indexLastDot - indexLastSlash - 1)

    End Function

    Private Function correctPathHtml(ByVal path As String) As String
        Dim indexLastSlash
        indexLastSlash = path.LastIndexOf(Globals.ThisDocument.Application.PathSeparator)
        Return path.Substring(0, indexLastSlash + 1)
    End Function

    Private Function correctPathEpub(ByVal path As String) As String
        Dim indexLastSlash
        indexLastSlash = path.LastIndexOf(Globals.ThisDocument.Application.PathSeparator)
        Return path.Substring(0, indexLastSlash)
    End Function

    Private Shared Function GetResourceText(ByVal resourceName As String) As String
        Dim asm As Reflection.Assembly = Reflection.Assembly.GetExecutingAssembly()
        Dim resourceNames() As String = asm.GetManifestResourceNames()
        For i As Integer = 0 To resourceNames.Length - 1
            If String.Compare(resourceName, resourceNames(i), StringComparison.OrdinalIgnoreCase) = 0 Then
                Using resourceReader As IO.StreamReader = New IO.StreamReader(asm.GetManifestResourceStream(resourceNames(i)))
                    If resourceReader IsNot Nothing Then
                        Return resourceReader.ReadToEnd()
                    End If
                End Using
            End If
        Next
        Return Nothing
    End Function

#End Region

    Function getDocumentXmlPart(ByVal package As Package) As PackagePart
        For Each docRel As PackageRelationship In package.GetRelationshipsByType("http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument")
            Return package.GetPart(PackUriHelper.ResolvePartUri(New Uri("/", UriKind.Relative), docRel.TargetUri))
        Next

        Return Nothing
    End Function


    Function getImageParts(ByVal docXmlPart As PackagePart) As System.Collections.Generic.List(Of PackagePart)
        Dim retList As System.Collections.Generic.List(Of PackagePart) = New System.Collections.Generic.List(Of PackagePart)
        For Each imageRel As PackageRelationship In docXmlPart.GetRelationshipsByType("http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")
            retList.Add(docXmlPart.Package.GetPart(PackUriHelper.ResolvePartUri(New Uri(docXmlPart.Uri.ToString(), UriKind.Relative), imageRel.TargetUri)))
        Next

        Return retList
    End Function

    Sub copyStream(ByVal source As Stream, ByVal destination As Stream)
        Dim buffer() As Byte
        ReDim buffer(4095)
        Dim read As Integer = 1
        While (True)
            read = source.Read(buffer, 0, buffer.Length)
            destination.Write(buffer, 0, read)
            If read <= 0 Then
                Exit While
            End If
        End While
        destination.Flush()
    End Sub


    Function cutUri(ByVal path As String) As String
        Return path.Substring(path.LastIndexOfAny("/") + 1)
    End Function

    Sub extractImages(ByVal destFolder As String, ByVal document As Word.Document)
        If Directory.Exists(destFolder) = False Then
            Directory.CreateDirectory(destFolder)
        End If

        document.SaveAs(destFolder & "tmpDoc1.docx")
        document.SaveAs(destFolder & "tmpDoc2.docx")
        Me.fileToDelete = destFolder & "tmpDoc1.docx"
        Dim sourceFile As String = destFolder & "tmpDoc1.docx"

        If Directory.Exists(destFolder & "images\") = False Then
            Directory.CreateDirectory(destFolder & "images\")
        End If

        Dim partUriDocument As Uri = PackUriHelper.CreatePartUri(New Uri(sourceFile, UriKind.Relative))
        Dim partUriResource As Uri = PackUriHelper.CreatePartUri(New Uri(sourceFile, UriKind.Relative))
        Dim package As Package = package.Open(sourceFile, FileMode.Open, FileAccess.Read)
        Dim docxPart As PackagePart = getDocumentXmlPart(package)

        If docxPart Is Nothing Then
            Return
        End If

        For Each imagePart As PackagePart In getImageParts(docxPart)
            Dim source As Stream = imagePart.GetStream()
            Dim destinationPath As String = destFolder & "images\" & cutUri(imagePart.Uri.ToString)
            Dim destination As Stream = File.OpenWrite(destinationPath)
            copyStream(source, destination)
            destination.Close()
            destination.Dispose()
        Next
        package.Close()
        Kill(Me.fileToDelete)
    End Sub

    Public Shared Function rgbIntToHex(ByVal int As Integer) As String
        If findWordColorCode(int) <> "NO_VALUE" Then
            Return findWordColorCode(int)
        End If
        int = int And 16777215 'sorgt dafür, dass nur die hintersten 24 Stellen (oder 6, wenn hexadezimal) behalten werden
        Dim value As String = int.ToString("X")
        For i As Integer = value.Length To 5
            value = "0" & value
        Next

        ' umstellen, da die 'RGB'-Funktion in Wirklichkeit BGR liefert
        Dim retVal As String = ""
        retVal = retVal & value.Substring(4, 2)
        retVal = retVal & value.Substring(2, 2)
        retVal = retVal & value.Substring(0, 2)

        Return retVal
    End Function

    Private Shared Function findWordColorCode(ByVal code As Integer) As String
        Dim retVal As String = "NO_VALUE"
        Select Case code
            Case -587137025
                retVal = "000000" ' schwarz (Zitat)
            Case -587137153
                retVal = "808080" ' hellgrau
            Case -553598977
                retVal = "173600" ' dunkelblau (großer Titel)
            Case -738148353
                retVal = "325886" 'blau
            Case -738131969
                retVal = "4F81BD" 'hellblau
            Case -721354753
                retVal = "C0504D" 'rot
        End Select

        Return retVal
    End Function


    Function readWordDocument(ByVal Doc As Word.Document, ByVal destinationFolder As String) As MyDocument

        'Dim version As String = Doc.Application.Version

        Dim numOfParagraphs As Integer = Doc.Paragraphs.Count()
        Dim myDocument As New MyDocument(numOfParagraphs)
        Dim myParagraph As MyParagraph
        Dim mySentence As MySentence
        Dim paragraphIndex As Integer = 0

        ' ## Bilder behandeln
        extractImages(destinationFolder, Doc)

        Dim shapes As Word.Shapes = Doc.Shapes
        For Each shape As Word.Shape In shapes

            Dim name As String = shape.Name
            Dim links As Single = shape.Left
            Dim oben As Single = shape.Top
            Dim hoch As Single = shape.Height
            Dim weit As Single = shape.Width
            Dim alt As String = shape.AlternativeText
        Next

        ' following code segment saves necessary information for every Picture

        Dim wordDoc = Globals.ThisDocument.Application.ActiveDocument

        Dim collection As Word.Shapes = wordDoc.Shapes
        Dim num = wordDoc.Shapes.Count

        Dim stat As Word.WdStatistic = Word.WdStatistic.wdStatisticPages
        Dim num2 = wordDoc.ComputeStatistics(stat, False)
        Dim counter = 1
        For page As Integer = 1 To num2
            Dim wdAppSelection As Word.Selection = wordDoc.ActiveWindow.Selection
            Dim what As Object = Word.WdGoToItem.wdGoToPage
            Dim which As Object = Word.WdGoToDirection.wdGoToAbsolute
            Dim count As Object = page
            wdAppSelection.GoTo(what, which, count)
            Dim index As Object = "\Page"
            Dim rng As Word.Range = wordDoc.Bookmarks.Item(index).Range

            For Each oshape As Word.Shape In collection

                If (oshape.Type = Microsoft.Office.Core.MsoShapeType.msoPicture) Then
                    If (oshape.Name.Contains("Picture")) Then
                        If (oshape.Anchor.InRange(rng)) Then
                            'MessageBox.Show(oshape.Name + " is on Page " + count.ToString())
                            Dim newPicture As MyPicture = New MyPicture(oshape.Height, oshape.Width, oshape.Left, oshape.Top, count)
                            myDocument.insertPicture(newPicture)
                        End If
                    End If
                End If

            Next
        Next
        myDocument.relateFilenamesToPictures()


        ' ## save formats which are in the GUI
        For Each style As Word.Style In Doc.Styles
            myDocument.insertFormatByStyle(style)
        Next

        For Each paragraph As Word.Paragraph In Doc.Paragraphs

            myDocument.paragraphs(paragraphIndex) = New MyParagraph(paragraph.Range.Sentences.Count)
            myParagraph = myDocument.paragraphs(paragraphIndex)
            Dim sentenceIndex As Integer = 0

            ' ## empty paragraph; only character is: <carriage return>
            If paragraph.Range.Characters.Count = 1 AndAlso (AscW(paragraph.Range.Text) = 13) Then
                myParagraph.empty = True
                paragraphIndex += 1
                Continue For
            End If

            For Each sentence As Word.Range In paragraph.Range.Sentences

                myParagraph.sentences(sentenceIndex) = New MySentence(sentence.Words.Count)
                mySentence = myParagraph.sentences(sentenceIndex)
                Dim formats As New Dictionary(Of MyFormat, Integer)

                'Formats:
                'Searching for the predominant format
                For Each word As Word.Range In sentence.Words

                    Dim pairValue = 1               ' amount of words which have a shared format
                    Dim highestValue = 0            ' highest value of all pairValues

                    Dim newFormat As MyFormat = New MyFormat(word.Font.Name, word.Font.Size, word.Font.Bold, word.Font.Italic, (word.Font.Underline > 0), rgbIntToHex(word.Font.Color.GetHashCode))

                    ' searching if newFormat is already in 'globalFormats'
                    ' if not, its probably "handmade"; add it though; for we crash if we don't
                    If myDocument.indexByFormat(newFormat) = -1 Then
                        myDocument.insertFormat(newFormat)
                    End If

                    ' searching if newFormat is already in "formats"
                    ' if found, removing it from "formats" and increasing pairValue by 1.
                    For Each pair In formats
                        If newFormat.isEqual(pair.Key) Then
                            pairValue = pair.Value + 1
                            formats.Remove(pair.Key)
                            Exit For
                        End If
                    Next

                    formats.Add(newFormat, pairValue)
                    If highestValue < pairValue Then
                        ' new predominant format found
                        mySentence.commonFormat = myDocument.indexByFormat(newFormat)
                        highestValue = pairValue
                    End If

                Next


                ' ## save word per word with the corresponding format
                Dim wordIndex As Integer = 0

                For Each word As Word.Range In sentence.Words

                    If (AscW(word.Text.Substring(0, 1))) >= 32 Then
                        mySentence.words(wordIndex) = word.Text
                        wordIndex += 1
                    ElseIf (AscW(word.Text.Substring(0, 1))) = 13 Then
                        ' carriage return
                        wordIndex += 1
                    ElseIf AscW(word.Text.Substring(0, 1)) = 9 Then
                        ' Tabulator
                        mySentence.words(wordIndex) = ""
                        mySentence.specialChars.Add(wordIndex, "<TAB>")
                        wordIndex += 1
                    ElseIf AscW(word.Text.Substring(0, 1)) = 11 Then
                        ' erzwungener Zeilenumbruch
                        mySentence.words(wordIndex) = ""
                        mySentence.specialChars.Add(wordIndex, "<BR>")
                        wordIndex += 1
                    Else
                        wordIndex += 1
                    End If

                    Dim newFormat As New MyFormat(word)
                    If Not (newFormat.isEqual(myDocument.globalFormats(mySentence.commonFormat))) Then
                        Dim sIndex As Integer = myDocument.indexByFormat(newFormat)
                        If sIndex <> -1 Then
                            mySentence.specialFormat.Add(wordIndex - 1, myDocument.indexByFormat(newFormat))
                        End If
                    End If
                Next

                mySentence.cleanArray()
                sentenceIndex += 1
            Next

            paragraphIndex += 1
        Next

        'objWriter.Close()
        'objWriter.Dispose()

        Return myDocument

    End Function

End Class
